perm filename RPG[TIM,LSP] blob
sn#679556 filedate 1982-09-29 generic text, type T, neo UTF8
(FILECREATED "29-Sep-82 21:31:11" <CSD.BENNETT>RPG..9 6396
changes to: MAKE-POSSIBILITY-1 MAKE-POSSIBILITY-2
previous date: "29-Sep-82 21:10:24" <CSD.BENNETT>RPG..8)
(PRETTYCOMPRINT RPGCOMS)
(RPAQQ RPGCOMS ((FNS * RPGFNS)
(VARS * RPGVARS)
(BLOCKS * RPGBLOCKS)))
(RPAQQ RPGFNS (PAIRS PAIRS1 PAIRS2 MAKE-POSSIBILITY-1
MAKE-POSSIBILITY-2 PAIRX PAIRY))
(DEFINEQ
(PAIRS
[LAMBDA (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS) (* jsb: "29-Sep-82 20:55")
([LAMBDA (XXX)
(MAPCONC XXX (FUNCTION PAIRX] |
(MAPCAR [COND
((ILESSP (LENGTH X)
(IPLUS (COND
(NIL-PAIRS 1)
(T 0))
(LENGTH Y)))
(PAIRS1 (MAKE-POSSIBILITY-1 X Y FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)))
(T (PAIRS2 (MAKE-POSSIBILITY-2 Y X FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS]
(FUNCTION (LAMBDA (I)
(CDR I])
(PAIRS1
[LAMBDA (L) (* edited:
"29-Sep-82 21:08")
(COND
[(NULL L) |
(QUOTE ((NIL] |
(T
([LAMBDA (CAND POSS)
(MAPCONC
(PAIRS1 (CDR L))
[FUNCTION (LAMBDA (PAIRS)
(PROGN
([LAMBDA (AVOID ANS)
(MAPCONC
POSS
[FUNCTION (LAMBDA (I)
([LAMBDA (Q)
(COND
(Q (CONS Q NIL]
(PROGN
(COND
((CAR (MEMBER (CAR I)
AVOID))
(CONS AVOID ANS))
(T
(CONS (CONS (CAR I)
AVOID)
(CONS (CONS CAND
(CDR I))
ANS]
NIL]
(CAR PAIRS)
(CDR PAIRS]
NIL]
(CAAR L)
(CDAR L])
(PAIRS2
[LAMBDA (L) (* edited:
"29-Sep-82 21:09")
(COND
[(NULL L) |
(QUOTE ((NIL] |
(T
([LAMBDA (CAND POSS)
(MAPCONC
(PAIRS2 (CDR L))
[FUNCTION (LAMBDA (PAIRS)
(PROGN
([LAMBDA (AVOID ANS)
(MAPCONC
POSS
[FUNCTION (LAMBDA (I)
([LAMBDA (Q)
(COND
(Q (CONS Q NIL]
(PROGN
(COND
((CAR (MEMBER (CAR I)
AVOID))
(CONS AVOID ANS))
(T
(CONS (CONS (CAR I)
AVOID)
(CONS (CONS (CDR I)
CAND)
ANS]
NIL]
(CAR PAIRS)
(CDR PAIRS]
NIL]
(CAAR L)
(CDAR L])
(MAKE-POSSIBILITY-1
[LAMBDA (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)
(* edited:
"29-Sep-82 21:30")
([LAMBDA (N)
([LAMBDA (Q)
(COND
[NIL-PAIRS (MAPC Q (FUNCTION (LAMBDA (I)
(RPLACD I (CONS (QUOTE (NIL)) |
(CDR I] |
(Q]
(MAPCONC
X
[FUNCTION (LAMBDA (I)
(PROGN
(SETQ N 0)
([LAMBDA (A)
(AND A (OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(BLKAPPLY APPLY-CONSTRAINTS
(LIST CONSTRAINTS)))
(LIST (CONS I A]
(MAPCONC
Y
[FUNCTION (LAMBDA (J)
([LAMBDA (Q)
(COND
(Q (CONS Q NIL]
(PROGN (SETQ N (ADD1 N))
(COND
((OR (NULL FUN)
(BLKAPPLY FUN
(LIST I J)))
(CONS N J]
NIL]
NIL]
0])
(MAKE-POSSIBILITY-2
[LAMBDA (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)
(* edited:
"29-Sep-82 21:31")
([LAMBDA (N)
([LAMBDA (Q)
(COND
[NIL-PAIRS (MAPC Q (FUNCTION (LAMBDA (I)
(RPLACD I (CONS (QUOTE (NIL)) |
(CDR I] |
(Q]
(MAPCONC
X
[FUNCTION (LAMBDA (I)
(PROGN
(SETQ N 0)
([LAMBDA (A)
(AND A (OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(BLKAPPLY APPLY-CONSTRAINTS
(LIST CONSTRAINTS)))
(LIST (CONS I A]
(MAPCONC
Y
[FUNCTION (LAMBDA (J)
([LAMBDA (Q)
(COND
(Q (CONS Q NIL]
(PROGN (SETQ N (ADD1 N))
(COND
((OR (NULL FUN)
(BLKAPPLY FUN
(LIST J I)))
(CONS N J]
NIL]
NIL]
0])
(PAIRX
[LAMBDA (I) (* jsb: "29-Sep-82 20:46")
(AND (PROGN (COND |
[MUST-APPEAR |
|
(* (*CATCH (QUOTE OUT) (PROGN (MAPC I (FUNCTION (LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR) |
(*THROW (QUOTE OUT) T)))))) NIL)) We implement the *CATCH and *THROW using NLSETQ and ERROR!. |
If the *THROW is ever executed then the *CATCH returns T, otherwise it will return NIL. |
In INTERLISP, if ERROR! is called the surrounding NLSETQ is exited with value NIL, otherwise NLSETQ |
returns the LIST of the value. Hence (NOT (NLSETQ --)) is equivalent to the original construct.) |
|
|
(NOT (NLSETQ (MAPC I (FUNCTION (LAMBDA (I) |
(COND |
((MEMBER (CDR I) |
MUST-APPEAR) |
(ERROR!] |
(T))) |
(LIST I])
(PAIRY
[LAMBDA (I) (* jsb: "29-Sep-82 20:46")
(COND |
((OR (NOT MUST-APPEAR) |
(for Z in I thereis (MEMBER (CDR I) |
MUST-APPEAR))) |
(LIST I])
)
(RPAQQ RPGVARS (A B))
(RPAQQ A ((1 2)
(7 8)
(9 0)
(a b c)
(a b c)
(d e f)
(d e f)
(g h i)
(g h i)
(j k l)
(m n o)
(p q r)))
(RPAQQ B ((a b c)
(j k l)
(d e f)
(p q r)
(g h i)
(9 0)
(a b c)
(p q r)
(7 8)
(j k l)
(2 1)
(3 2)
(8 7)
(9 8)
(0 9)
(m n o)
(d e f)
(j k l)
(m n o)
(d e f)
(p q r)
(g h i)))
(RPAQQ RPGBLOCKS ((PAIRSBBLOCK PAIRS PAIRX PAIRS1 PAIRS2
MAKE-POSSIBILITY-1 MAKE-POSSIBILITY-2
(ENTRIES PAIRS)
(SPECVARS MUST-APPEAR))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: PAIRSBBLOCK PAIRS PAIRX PAIRS1 PAIRS2 MAKE-POSSIBILITY-1
MAKE-POSSIBILITY-2 (ENTRIES PAIRS)
(SPECVARS MUST-APPEAR))
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (398 5581 (PAIRS 410 . 920) (PAIRS1 924 . 1663) (PAIRS2
1667 . 2406) (MAKE-POSSIBILITY-1 2410 . 3299) (MAKE-POSSIBILITY-2 3303 .
4192) (PAIRX 4196 . 5266) (PAIRY 5270 . 5578)))))
STOP